Visual Basic Source Code

home *** CD-ROM | disk | FTP | other *** search

/ Visual Basic Source Code / Visual Basic Source Code.iso / vbsource / golf / golf.frm (.txt) < prev next >

Wrap

Visual Basic Form | 1995-04-02 | 24.6 KB | 720 lines

VERSION 2.00 Begin Form Form1 AutoRedraw = -1 'True BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Golf" ClientHeight = 6765 ClientLeft = 1230 ClientTop = 1065 ClientWidth = 6525 Height = 7170 Icon = GOLF.FRX:0000 Left = 1170 LinkTopic = "Form1" MaxButton = 0 'False ScaleHeight = 6765 ScaleWidth = 6525 Top = 720 Width = 6645 Begin CommandButton btnHelp Caption = "Help" Height = 315 Left = 4200 TabIndex = 16 Tag = "/3d_inset/" Top = 5760 Width = 2115 End Begin PictureBox picReference AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H00C0C0C0& FillStyle = 0 'Solid Height = 6030 Left = 6600 MousePointer = 2 'Cross ScaleHeight = 400 ScaleMode = 3 'Pixel ScaleWidth = 250 TabIndex = 2 Tag = "/3d_inset/" Top = 420 Width = 3780 End Begin CommandButton btnNewGame Caption = "New Game" Height = 315 Left = 4200 TabIndex = 13 Tag = "/3d_inset/" Top = 5340 Width = 2115 End Begin CommandButton btnQuit Caption = "Club House" Height = 315 Left = 4200 TabIndex = 6 Tag = "/3d_inset/" Top = 6180 Width = 2115 End Begin PictureBox picBG AutoRedraw = -1 'True AutoSize = -1 'True BackColor = &H00008000& FillStyle = 0 'Solid Height = 6030 Left = 180 MousePointer = 2 'Cross ScaleHeight = 400 ScaleMode = 3 'Pixel ScaleWidth = 250 TabIndex = 0 Tag = "/3d_inset/" Top = 480 Width = 3780 End Begin Label lblCourseName Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Course Name" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 180 TabIndex = 15 Tag = "/3d_raised/" Top = 75 Width = 6135 End Begin Label lblInfo BackColor = &H00C0C0C0& BorderStyle = 1 'Fixed Single Caption = "Double-click behind the ball to swing. Distance from the ball increases swing strength." FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 855 Left = 4320 TabIndex = 14 Tag = "/3d_inset/" Top = 1500 Width = 1875 End Begin Label Label5 Alignment = 2 'Center BackStyle = 0 'Transparent BorderStyle = 1 'Fixed Single Caption = "Select a Club" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 8.25 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 4380 TabIndex = 8 Tag = "/3d_raised/" Top = 4080 Width = 1740 End Begin Image imgClub BorderStyle = 1 'Fixed Single Height = 645 Index = 2 Left = 5580 Picture = GOLF.FRX:0302 Top = 4440 Width = 525 End Begin Image imgClub BorderStyle = 1 'Fixed Single Height = 645 Index = 1 Left = 4980 Picture = GOLF.FRX:06B0 Top = 4440 Width = 525 End Begin Image imgClub BorderStyle = 1 'Fixed Single Height = 645 Index = 0 Left = 4380 Picture = GOLF.FRX:0A5E Top = 4440 Width = 525 End Begin Label Label6 Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Score" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 4380 TabIndex = 12 Tag = "/3d_raised/" Top = 3240 Width = 1755 End Begin Label lblScore Alignment = 2 'Center BackColor = &H0080FFFF& BorderStyle = 1 'Fixed Single Caption = "0" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 255 Left = 4380 TabIndex = 11 Tag = "/3d_inset/" Top = 3600 Width = 1755 End Begin Label lblPar Alignment = 2 'Center BackColor = &H0080FFFF& BorderStyle = 1 'Fixed Single Caption = "0" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 255 Left = 5340 TabIndex = 10 Tag = "/3d_inset/" Top = 1020 Width = 855 End Begin Label lblStrokes Alignment = 2 'Center BackColor = &H0080FFFF& BorderStyle = 1 'Fixed Single Caption = "0" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 255 Left = 4680 TabIndex = 9 Tag = "/3d_inset/" Top = 2820 Width = 1095 End Begin Label lblHole Alignment = 2 'Center BackColor = &H0080FFFF& BorderStyle = 1 'Fixed Single Caption = "0" FontBold = -1 'True FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00FF0000& Height = 255 Left = 4320 TabIndex = 7 Tag = "/3d_inset/" Top = 1020 Width = 855 End Begin Label Label4 Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Strokes" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 4680 TabIndex = 4 Tag = "/3d_raised/" Top = 2460 Width = 1095 End Begin Label Label3 Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Par" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 5340 TabIndex = 3 Tag = "/3d_raised/" Top = 660 Width = 855 End Begin Label Label1 Alignment = 2 'Center BackStyle = 0 'Transparent Caption = "Hole" FontBold = 0 'False FontItalic = 0 'False FontName = "MS Sans Serif" FontSize = 9.75 FontStrikethru = 0 'False FontUnderline = 0 'False ForeColor = &H00800000& Height = 255 Left = 4320 TabIndex = 1 Tag = "/3d_raised/" Top = 660 Width = 855 End Begin Shape Shape1 BorderColor = &H000000FF& BorderWidth = 4 Height = 660 Left = 4380 Top = 4440 Width = 540 End Begin Label lblFrame1 BackStyle = 0 'Transparent ForeColor = &H00C0C0C0& Height = 4755 Left = 4200 TabIndex = 5 Tag = "/3d_inset/" Top = 480 Width = 2115 End Option Explicit '------------------------------------------------------------ ' Constants and module-level variables used in GOLF.MAK '------------------------------------------------------------ ' Valid game states. Const GAME_OVER = 0 Const GAME_IN_PROGRESS = 1 ' Available clubs (we travel light). Const CLUB_DRIVER = 0 Const CLUB_IRON = 1 Const CLUB_PUTTER = 2 ' The ball's coordinates. Dim mBall As tLocation Dim mMouse As tLocation Dim mDelta As tLocation ' An array of structures defining individual ' holes in the course. Dim mHole(1 To 18) As tHole ' The actual number of holes in the ' current course. Dim mNumHoles As Integer ' The available clubs. Dim mClubFactor(0 To 2) As Integer Dim mClubNumber As Integer Dim mGameState As Integer ' The total par for the course so far; ' used for displaying score. Dim mTotalPar As Integer Sub btnHelp_Click () '------------------------------------------------------------ ' Display the help screen. '------------------------------------------------------------ Const SHOW_MODAL = 1 frmAboutGolf.Show SHOW_MODAL End Sub Sub btnNewGame_Click () '------------------------------------------------------------ ' Reset everything for a new game. '------------------------------------------------------------ mGameState = GAME_IN_PROGRESS mTotalPar = 0 lblScore = "0 - Par" SetupHole 1 End Sub Sub btnQuit_Click () '------------------------------------------------------------ ' Exit the program. '------------------------------------------------------------ Unload Me End Sub Sub DrawBall () '------------------------------------------------------------ ' Redraw the ball at its current x-y position. '------------------------------------------------------------ picBG.Cls picBG.DrawWidth = 2 picBG.PSet (mBall.x, mBall.y), MAGENTA picBG.DrawWidth = 1 End Sub Sub Form_Load () '------------------------------------------------------------ ' Read the game data and set up the first game. '------------------------------------------------------------ Randomize AppPath = App.Path If Right$(AppPath, 1) <> "\" Then AppPath = AppPath & "\" ReadGameData InitClubs Me.Show CenterForm Me Paint3D Me Pause 1 btnNewGame_Click End Sub Function GetLocationByColor (AColor As Long) As String '------------------------------------------------------------ ' Given a color, return a string indicating what that color ' corresponds to. '------------------------------------------------------------ Dim i As Integer Select Case AColor Case RED: GetLocationByColor = "HOLE" Case BLUE, DK_BLUE, DK_CYAN: GetLocationByColor = "WATER" Case WHITE, YELLOW: GetLocationByColor = "SANDTRAP" Case Else GetLocationByColor = "" End Select End Function Sub imgClub_Click (Index As Integer) '------------------------------------------------------------ ' Select a new club. '------------------------------------------------------------ Shape1.Move imgClub(Index).Left, imgClub(Index).Top mClubNumber = Index End Sub Function InHole (x As Integer, y As Integer) As Integer '------------------------------------------------------------ ' Return True if this x-y location is in the hole, false ' otherwise. '------------------------------------------------------------ Dim DC As Integer DC = picReference.hDC If GetPixel(DC, x, y) = RED Or GetPixel(DC, x + 1, y) = RED Then InHole = True ElseIf GetPixel(DC, x, y - 1) = RED Or GetPixel(DC, x + 1, y - 1) = RED Then InHole = True ElseIf GetPixel(DC, x, y + 1) = RED Or GetPixel(DC, x + 1, y + 1) = RED Then InHole = True Else InHole = False End If End Function Sub InitClubs () '------------------------------------------------------------ ' Set the club factor array. This determines the distance ' that the ball will go when hit wil a particular type of ' club. '------------------------------------------------------------ mClubFactor(CLUB_DRIVER) = 8 mClubFactor(CLUB_IRON) = 3 mClubFactor(CLUB_PUTTER) = 1 End Sub Function OutOfBounds (x As Integer, y As Integer) As Integer '------------------------------------------------------------ ' Returns True if the x-y coordinate is outside the bitmap. '------------------------------------------------------------ Dim BoundsMargin As Integer BoundsMargin = 4 OutOfBounds = False If (x < BoundsMargin) Or (x > picBG.ScaleWidth - BoundsMargin) Or (y < BoundsMargin) Or (y > picBG.ScaleHeight - BoundsMargin) Then OutOfBounds = True End If End Function Sub picBG_DblClick () '------------------------------------------------------------ ' Hit the ball. This is where most of the action happens. '------------------------------------------------------------ Dim rc As Integer Dim slope As Single Dim Dist As Single Dim MaxDist As Single Dim direct As tLocation Dim i As Integer Dim xf As Single, yf As Single Dim OK As Integer Dim BG_Color As Long Dim Location As String Dim PauseFactor As Single Dim InTree As Integer Dim InSandTrap As Integer Dim Temp As tLocation Dim MoveDir As Integer Dim WaveFileName As String ' Can't hit the ball if you're not playing a game. If mGameState = GAME_OVER Then Exit Sub InTree = False lblInfo = "Double-click behind the ball to swing. " lblInfo = lblInfo & "Distance from the ball increases swing strength." mDelta.x = mBall.x - mMouse.x If mDelta.x = 0 Then mDelta.x = 1 mDelta.y = mBall.y - mMouse.y MaxDist = Sqr(mDelta.x ^ 2 + mDelta.y ^ 2) * mClubFactor(mClubNumber) ' If this is the player's first shot, they're on the tee, so ' they can hit a bit farther. If lblStrokes > 0 Then If MaxDist > (picBG.ScaleHeight / 3) Then MaxDist = picBG.ScaleHeight / 3 End If ' Bump up strokes lblStrokes = lblStrokes + 1 ' What color is the ball over? BG_Color = GetPixel(picReference.hDC, mBall.x, mBall.y) ' Are we in a tree? If (BG_Color = BLACK) Or (BG_Color = BROWN) Then InTree = True MaxDist = 2 * mClubFactor(mClubNumber) End If ' In a sand trap... If (BG_Color = WHITE) Or (BG_Color = YELLOW) Then ' If they want to make any progress, they'd better ' use the iron. If mClubNumber = CLUB_IRON Then MaxDist = MaxDist * .75 Else MaxDist = 2 End If End If slope = Abs(mDelta.y / mDelta.x) If mDelta.x > 0 Then direct.x = 1 ElseIf mDelta.x < 0 Then direct.x = -1 Else direct.x = 0 End If If mDelta.y > 0 Then direct.y = 1 ElseIf mDelta.y < 0 Then direct.y = -1 Else direct.y = 0 End If xf = mBall.x yf = mBall.y OK = True i = 0 picBG.CurrentX = mBall.x picBG.CurrentY = mBall.y ' Pick the appropriate sound for the club used. Select Case mClubNumber Case CLUB_DRIVER: WaveFileName = "SWING1.WAV" Case CLUB_IRON: WaveFileName = "SWING2.WAV" Case CLUB_PUTTER: WaveFileName = "SWING3.WAV" End Select rc = sndPlaySound(AppPath & WaveFileName, SND_ASYNC) Pause .25 PauseFactor = .001 * Abs(mDelta.y * 1.85) ' Draw the ball as it moves, showing its trajectory. While OK i = i + 1 xf = xf + direct.x yf = yf + (slope * direct.y) Dist = Sqr(CInt(mBall.x - xf) ^ 2 + CInt(mBall.y - yf) ^ 2) If Dist >= MaxDist Then OK = False picBG.Line -(CInt(xf), CInt(yf)), QBColor(4) Pause PauseFactor BG_Color = GetPixel(picReference.hDC, CInt(xf), CInt(yf)) ' Yikes! Out of Bounds! If OutOfBounds(CInt(xf), CInt(yf)) Then lblStrokes = lblStrokes + 2 If CInt(Rnd * 2) = 1 Then lblInfo = "Your ball went out of bounds (and hit the club house). Two stroke penalty." rc = sndPlaySound(AppPath & "OUTOBND1.WAV", SND_ASYNC) Else lblInfo = "Your ball went out of bounds (and hit a by-stander). Two stroke penalty." rc = sndPlaySound(AppPath & "OUTOBND2.WAV", SND_ASYNC) End If DrawBall Exit Sub End If ' Oops! Hit a Tree! If (BG_Color = BLACK) And (Not InTree) Then rc = sndPlaySound(AppPath & "TREEHIT.WAV", SND_ASYNC) OK = False End If ' In the Hole! If InHole(CInt(xf), CInt(yf)) Then rc = sndPlaySound(AppPath & "INHOLE.WAV", SND_SYNC) ' Scoring... lblScore = CInt(Left(lblScore, InStr(lblScore, " ") - 1)) + lblStrokes mTotalPar = mTotalPar + lblPar If lblScore > mTotalPar Then lblScore = Format$(lblScore) & " - " & Format$(lblScore - mTotalPar) & " over par" ElseIf lblScore < mTotalPar Then lblScore = Format$(lblScore) & " - " & Format$(mTotalPar - lblScore) & " under par" Else lblScore = Format$(lblScore) & " - Par" End If If lblHole = mNumHoles Then mGameState = GAME_OVER rc = sndPlaySound(AppPath & "APPLAUS2.WAV", SND_ASYNC) Exit Sub Else SetupHole lblHole + 1 Exit Sub End If End If Wend mBall.x = CInt(xf) mBall.y = CInt(yf) ' Where is the ball? BG_Color = GetPixel(picReference.hDC, mBall.x, mBall.y) Location = GetLocationByColor(BG_Color) ' Did it land in the water? If Location = "WATER" Then Temp.x = mBall.x Temp.y = mBall.y lblInfo = "One stroke penalty for going in the water hazard." lblStrokes = lblStrokes + 1 rc = sndPlaySound(AppPath & "SPLASH.WAV", SND_ASYNC) If mBall.x > (picBG.ScaleWidth / 2) Then MoveDir = -5 Else MoveDir = 5 End If While ((BG_Color = BLUE) Or (BG_Color = DK_BLUE) Or (BG_Color = DK_CYAN)) Temp.x = Temp.x + MoveDir picBG.Line -(Temp.x, Temp.y), YELLOW Pause .25 BG_Color = GetPixel(picReference.hDC, Temp.x, Temp.y) Wend mBall.x = Temp.x ' Did it land in a sand trap? ElseIf Location = "SANDTRAP" Then lblInfo = "You're in a bunker." rc = sndPlaySound(AppPath & "BUNKER2.WAV", SND_ASYNC) End If DrawBall End Sub Sub picBG_MouseMove (Button As Integer, Shift As Integer, x As Single, y As Single) '------------------------------------------------------------ ' Keep track of the mouse's position. '------------------------------------------------------------ mMouse.x = x mMouse.y = y End Sub Sub ReadGameData () '------------------------------------------------------------ ' Read the GAMEINFO.TXT file, and build the data structures ' that define the holes. '------------------------------------------------------------ Dim fnum As Integer Dim ALine As String Dim HoleNum As Integer Dim DefaultTee As tLocation Dim DefaultPar As Integer Dim ID As String On Error Resume Next DefaultTee.x = picBG.ScaleWidth \ 2 DefaultTee.y = picBG.ScaleHeight - 50 DefaultPar = 5 fnum = FreeFile Open AppPath & "GAMEINFO.TXT" For Input As fnum If Err > 0 Then MsgBox "Couldn't find the game definition file.", MB_OK Or MB_ICONEXCLAMATION, "Golf" Unload Me End If HoleNum = 0 While Not EOF(fnum) Line Input #fnum, ALine ALine = Trim$(ALine) If UCase$(ALine) = "NEW HOLE" Then HoleNum = HoleNum + 1 Else ID = Trim$(UCase$(PopField(ALine, ":"))) Select Case ID Case "COURSE": lblCourseName = Trim$(ALine) Case "FILE": mHole(HoleNum).FileName = Trim$(ALine) Case "TEE": mHole(HoleNum).Tee.x = CInt(PopField(ALine, ",")) If Err > 0 Then mHole(HoleNum).Tee.x = DefaultTee.x mHole(HoleNum).Tee.y = CInt(ALine) If Err > 0 Then mHole(HoleNum).Tee.y = DefaultTee.y Case "PAR" mHole(HoleNum).Par = CInt(ALine) If Err > 0 Then mHole(HoleNum).Par = DefaultPar End Select End If Wend Close fnum mNumHoles = HoleNum On Error GoTo 0 End Sub Sub SetupHole (ByVal HoleNum As Integer) '------------------------------------------------------------ ' Set up a new hole: draw the background, reset labels, and ' place the ball on the tee. '------------------------------------------------------------ Dim x As Integer Dim BltLeft As Integer Dim rc As Integer On Error Resume Next picReference.Picture = LoadPicture(AppPath & mHole(HoleNum).FileName) If Err > 0 Then MsgBox "Couldn't find bitmap for Hole " & Format$(HoleNum) & "!", MB_OK Or MB_ICONSTOP, "Golf" End End If ' Slide the background in from the right, with sound effects. rc = sndPlaySound(AppPath & "SLIDE.WAV", SND_ASYNC) picBG.AutoRedraw = False For x = 2 To picBG.ScaleWidth BltLeft = picBG.ScaleWidth - x rc = BitBlt(picBG.hDC, BltLeft, 0, x, picBG.ScaleHeight, picReference.hDC, 0, 0, SRCCOPY) Pause .001 Next picBG.AutoRedraw = True picBG.Picture = picReference.Picture ' Initialize variables for this hole. lblHole = HoleNum lblPar = mHole(lblHole).Par mBall.x = mHole(lblHole).Tee.x mBall.y = mHole(lblHole).Tee.y lblStrokes = 0 DrawBall ' The default club will be a driver. imgClub_Click CLUB_DRIVER End Sub